home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM BV3 / BMUG PD-ROM Version BV3 (CDRM1097900).iso / Programming / Programming Languages / Pocket Forth 6 / Source / Interpreter.txt < prev    next >
Encoding:
Text File  |  1992-05-18  |  4.1 KB  |  144 lines  |  [TEXT/McSk]
  1. ; Interpreter.txt 8:12:05 AM  2/11/87
  2. ; add Held 2:45:49 PM  5/31/87
  3. ; v 0.3 DA compatable 11:47:16 AM  1/21/88
  4. ; Mon Apr 25, 1988 15:12:04 macros
  5. ; Wed Apr 27, 1988 12:30:48 v 0.4
  6. ; Mon Jun 03, 1991 23:40:00 restructure
  7. ; Wed Apr 01, 1992 00:11:00 remove uflow, add stackSize, numError
  8. ; Sun Apr 12, 1992 22:46:00 add fp routines, move user vars to asupport
  9.  
  10.  
  11. Cold:    ; setup BP  [a3]
  12.     LEA    Bottom,BP
  13.     MOVE.L    A1,Expand-Base(BP)    ; a present from the application
  14.  
  15.     ; setup the stacks, PS and RS [a6 & a7]
  16.     LEA    IntA7-Base(BP),A0    ; A7 is already where it should be.
  17.     MOVE.L    RS,(A0)+        ; Save initial value of RS at IntA7
  18.     MOVEA.L    RS,PS
  19.     SUBA.W    stackSize-base(BP),RS    ; variable stack size added 3/30/92
  20.     MOVE.L    RS,(A0)+        ; save return stack bottom at Rzero
  21.     SUBQ.L    #8,PS            ; leave room for under flow ...
  22.     SUBQ.L    #2,PS            ; ... leave _plenty_ of room
  23.     MOVE.L    PS,(A0)            ; Put parameter stack bot. at Szero
  24.  
  25.     ; setup DP  [a2]
  26.     MOVE    FreePt-Base(BP),D0    ; rel compile buffer pointer
  27.     LEA    0(BP,D0.W),DP        ; abs addr into DP register
  28.  
  29.     ; setup Dict [d6]
  30.     CLR.L    Dict
  31.     MOVE    DictPt-base(BP),Dict    ; rel.addr of the last dict. entry
  32.  
  33.     ; set the dictionary size
  34.     MOVE    freesz-base(BP),-(PS)
  35.     JSR    grow-base(BP)
  36.  
  37.     ; setup the interface
  38.     JSR    MacStart-base(BP)    ; moved 6/3/91
  39.  
  40. Warm:    MOVEA.L    Rzero-Base(BP),RS    ; reset return stack
  41.     MOVEA.L    Szero-Base(BP),PS    ; reset parameter stack
  42.     JSR    page-Base(BP)        ; clear the page
  43.     MOVE    newer-base(BP),D0
  44.     JSR    0(BP,D0.W)        ; run the open routine 3/30/88
  45.     CLR.L    fcolon-base(BP)
  46.     BSET.B    #7,fint-base(BP)
  47. Restart:
  48.     BSR.S    GetInput        ; fill the tib with a line of input
  49. Main:    JSR    token-Base(BP)        ; get the next word of the line
  50.     MOVE    Dict,-(PS)        ; push pointer to last name
  51.     JSR    search-Base(BP)        ; find current token in dictionary
  52.     TST    (PS)+            ; found NOT IF,
  53.     BEQ.S    TestNum            ; ... assume its a number
  54.     BCLR    #7,fimmed-base(BP)    ; ELSE, immediate? IF
  55.     BNE.S    doex            ; ... do it
  56.     TST.B    fcolon-base(BP)        ; ELSE, compiling? NOT IF,
  57.     BEQ.S    doex            ; ... do it
  58.     BCLR    #7,fmacro-base(BP)    ; ELSE, macro? IF
  59.     BNE.S    domc
  60.     JSR    Compile-base(BP)    ; ELSE, compile a JSR to it
  61.     BRA.S    Main
  62.  
  63.   doex:    JSR    Execute-base(BP)
  64.     JSR    StkChk-base(BP)
  65.     BRA.S    Main
  66.  
  67.   domc:    JSR    mcomp-base(BP)
  68.     BRA.S    Main
  69.     
  70.   TestNum:    ; Test the token for integer or floating point numberness.
  71.     JSR    here-base(BP)        ; get the relative address of token
  72.     JSR    number-base(BP)        ; convert it to a value, if posible
  73.     TST    (PS)+            ;  was it?
  74.     BEQ.S    testfloat        ; if not, test for floating point
  75.     TST.B    fcolon-base(BP)        ; else, are you compiling?
  76.     BEQ.S    Main            ; if not, leave it on the stack
  77.     JSR    Literal-base(BP)    ; else, compile it as a literal
  78.     BRA.S    Main            ; then, get on with it
  79.  
  80.     TestFloat:    ; It's not an integer, try floating point.
  81.     BCLR    #7,fneg-base(BP)    ; Is it a negative number?
  82.     BEQ.S    @0
  83.     MOVE.B    #$2D,1(A2)        ; put in a negative sign
  84.     @0:    MOVE.L    A2,-(PS)
  85.     JSR    fnum-base(BP)        ; do the conversion (handles error)
  86.     TST.B    fcolon-base(bp)        ; if compiling, leave ...
  87.     BEQ.S    Main            ; ... it on the stack.
  88.     JSR    flit-base(BP)        ; else flit it
  89.     BRA.S    Main
  90.  
  91. GetInput:
  92.     TST.B    fint-base(BP)
  93.     BEQ    Pasting            ; Get a line from scrap data
  94.     TST.B    fcolon-base(BP)
  95.     BNE.S    Line
  96.     JSR    Prompt-Base(BP)
  97.     BRA.S    Line
  98.     
  99. Line:    JSR    ClearTermBuf-base(BP)
  100.     MOVE    #termbuf-base,-(PS)
  101.     MOVE    #80,-(PS)
  102.     JMP    expect-base(BP)
  103.  
  104. DictStart:
  105.     DCB.B    6,0            ; End of dictionary search
  106.     
  107.     DC.B    129,13,0,0        ; "{cr}" ( -- ) goto restart
  108.     DC.W    dictstart-base
  109. CRet:    MOVE.L    Rzero,RS        ; reset return stack
  110.     JMP    Restart-base(BP)    ; and jump
  111.     
  112.     DC.B    129,0,0,0        ; "{null}" ( -- ) same as cret
  113.     DC.W    cret-theLink
  114. NRet:    BRA.S    cret
  115.  
  116.  
  117.     DC.B    9,'?TE'            ; "?terminal" ( -- flag )
  118.     DC.W    nret-theLink        ;  was a key pressed?
  119. QTerm:    JSR    NextEvent-base(BP)
  120.     CLR    -(PS)
  121.     TST    kflag-base(BP)
  122.     BEQ.S    @0
  123.     SUBQ    #1,(PS)
  124.     @0:    RTS
  125.  
  126.     DC.B    3,'KEY'            ; "key" ( -- ascii )
  127.     DC.W    qterm-theLink        ;   wait for a key press
  128. Key:    BSR.S    Curs
  129.     @0:    JSR    NextEvent-base(BP)    ; set kflag if a key is pressed
  130.     TST    KFlag-base(BP)        ; ( among other things... )
  131.     BEQ.S    @0
  132.     BSR.S    NoCurs
  133.     MOVE    KFlag-base(BP),-(PS)
  134.     RTS
  135.  
  136. NoCurs:    MOVE    #10,-(SP)        ; SrcXor mode
  137.     _PenMode
  138.   Curs:    MOVE.L    #$00000006,-(SP)    ; move 6 pixels to the right
  139.     _Move
  140.     MOVE.L    #$0000FFFA,-(SP)    ; draw 6 pixels to the left
  141.     _Line
  142.     _PenNormal
  143.     RTS
  144.